home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / xerox-low.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  6.0 KB  |  174 lines
  1. ;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; This is the 1100 (Xerox version) of the file portable-low.
  28. ;;;
  29.  
  30. (in-package 'pcl)
  31.  
  32. (defmacro load-time-eval (form)
  33.   `(il:LOADTIMECONSTANT ,form))
  34.  
  35. ;;;
  36. ;;; make the pointer from an instance to its class wrapper be an xpointer.
  37. ;;; this prevents instance creation from spending a lot of time incrementing
  38. ;;; the large refcount of the class-wrapper.  This is safe because there will
  39. ;;; always be some other pointer to the wrapper to keep it around.
  40. ;;; 
  41. #+Xerox-Medley
  42. (defstruct (std-instance (:predicate std-instance-p)
  43.              (:conc-name %std-instance-)
  44.              (:constructor %%allocate-instance--class ())
  45.              (:fast-accessors t)
  46.              (:print-function %print-std-instance))
  47.   (wrapper nil :type il:fullxpointer)
  48.   (slots nil))
  49.  
  50. #+Xerox-Lyric
  51. (eval-when (eval load compile)
  52.   (il:datatype std-instance
  53.            ((wrapper il:fullxpointer)
  54.             slots))
  55.  
  56.   (xcl:definline std-instance-p (x)
  57.     (typep x 'std-instance))
  58.   
  59.   (xcl:definline %%allocate-instance--class ()
  60.     (il:create std-instance))
  61.  
  62.   (xcl:definline %std-instance-wrapper (x) 
  63.     (il:fetch (std-instance wrapper) il:of x))
  64.  
  65.   (xcl:definline %std-instance-slots (x) 
  66.     (il:fetch (std-instance slots) il:of x))
  67.  
  68.   (xcl:definline set-%std-instance-wrapper (x value) 
  69.     (il:replace (std-instance wrapper) il:of x il:with value))
  70.  
  71.   (xcl:definline set-%std-instance-slots (x value) 
  72.     (il:replace (std-instance slots) il:of x il:with value))
  73.  
  74.   (defsetf %std-instance-wrapper set-%std-instance-wrapper)
  75.  
  76.   (defsetf %std-instance-slots set-%std-instance-slots)
  77.  
  78.   (il:defprint 'std-instance '%print-std-instance)
  79.  
  80.   )
  81.  
  82. (defun %print-std-instance (instance &optional stream depth)  
  83.   ;; See the IRM, section 25.3.3.  Unfortunatly, that documentation is
  84.   ;; not correct.  In particular, it makes no mention of the third argument.
  85.   (cond ((streamp stream)
  86.      ;; Use the standard PCL printing method, then return T to tell
  87.      ;; the printer that we have done the printing ourselves.
  88.      (print-std-instance instance stream depth)
  89.      t)
  90.     (t 
  91.      ;; Internal printing (again, see the IRM section 25.3.3). 
  92.      ;; Return a list containing the string of characters that
  93.      ;; would be printed, if the object were being printed for
  94.      ;; real.
  95.      (list (with-output-to-string (stream)
  96.          (print-std-instance instance stream depth))))))
  97.  
  98.   ;;   
  99. ;;;;;; FUNCTION-ARGLIST
  100.   ;;
  101.  
  102. (defun function-arglist (x)
  103.   ;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and
  104.   ;; strings instead of symbols.  How silly.
  105.   (let ((arglist (il:arglist x)))
  106.     (when (symbolp arglist)
  107.       ;; This could be due to trying to extract the arglist of an interpreted
  108.       ;; function (though why that should be hard is beyond me).  On the other
  109.       ;; hand, if the function is compiled, it helps to ask for the "smart"
  110.       ;; arglist.
  111.       (setq arglist 
  112.         (if (consp (symbol-function x))
  113.         (second (symbol-function x))
  114.         (il:arglist x t))))
  115.     (if (symbolp arglist)
  116.     ;; Probably never get here, but just in case
  117.     (list '&rest 'rest)
  118.     ;; Make sure there are no strings where there should be symbols
  119.     (if (some #'stringp arglist)
  120.         (mapcar #'(lambda (a) (if (symbolp a) a (intern a))) arglist)
  121.         arglist))))
  122.  
  123. (defun printing-random-thing-internal (thing stream)
  124.   (let ((*print-base* 8))
  125.     (princ (il:\\hiloc thing) stream)
  126.     (princ "," stream)
  127.     (princ (il:\\loloc thing) stream)))
  128.  
  129. (defun record-definition (name type &optional parent-name parent-type)
  130.   (declare (ignore type parent-name))
  131.   ())
  132.  
  133.  
  134. ;;;
  135. ;;; FIN uses this too!
  136. ;;;
  137. (eval-when (compile load eval)
  138.   (il:datatype il:compiled-closure (il:fnheader il:environment))
  139.  
  140.   (il:blockrecord closure-overlay ((funcallable-instance-p il:flag)))  
  141.  
  142.   )
  143.  
  144. (defun compiled-closure-fnheader (compiled-closure)
  145.   (il:fetch (il:compiled-closure il:fnheader) il:of compiled-closure))
  146.  
  147. (defun set-compiled-closure-fnheader (compiled-closure nv)
  148.   (il:replace (il:compiled-closure il:fnheader) il:of compiled-closure nv))
  149.  
  150. (defsetf compiled-closure-fnheader set-compiled-closure-fnheader)
  151.  
  152. ;;;
  153. ;;; In Lyric, and until the format of FNHEADER changes, getting the name from
  154. ;;; a compiled closure looks like this:
  155. ;;; 
  156. ;;; (fetchfield '(nil 4 pointer)
  157. ;;;             (fetch (compiled-closure fnheader) closure))
  158. ;;;
  159. ;;; Of course this is completely non-robust, but it will work for now.  This
  160. ;;; is not the place to go into a long tyrade about what is wrong with having
  161. ;;; record package definitions go away when you ship the sysout; there isn't
  162. ;;; enough diskspace.
  163. ;;;             
  164. (defun set-function-name-1 (fn new-name uninterned-name)
  165.   (cond ((typep fn 'il:compiled-closure)
  166.      (il:\\rplptr (compiled-closure-fnheader fn) 4 new-name)
  167.      (when (and (consp uninterned-name)
  168.             (eq (car uninterned-name) 'method))
  169.        (let ((debug (si::compiled-function-debugging-info fn)))
  170.          (when debug (setf (cdr debug) uninterned-name)))))
  171.     (t nil))
  172.   fn)
  173.  
  174.